home *** CD-ROM | disk | FTP | other *** search
/ Experimental BBS Explossion 3 / Experimental BBS Explossion III.iso / pascal / pkpas1.zip / PKDEMO1.PAS < prev    next >
Pascal/Delphi Source File  |  1993-10-17  |  10KB  |  369 lines
  1. Program PkDemo1;
  2.  
  3. USES DOS,CRT, PKWareU;
  4.  
  5.  (***************************************************************
  6.  
  7.   First demo of PKware unit, showing use of the CentralFileHeadertype.
  8.  
  9.   Copyright Terry Sansom Oct, 1993.
  10.  
  11.   ***************************************************************)
  12.  
  13.  
  14.  
  15.  
  16. CONST
  17.      HexDigits : ARRAY[0..15] OF Char = '0123456789ABCDEF';
  18.  
  19.  
  20. TYPE D2 = String[2];
  21.  
  22.  
  23.  
  24. VAR EntryCount: Byte;
  25.     FileName: String;
  26.     CFH:       CentralFileHeaderType;
  27.     Error: Word;
  28.  
  29. { //////////////////////////  Global routines \\\\\\\\\\\\\\\\\\\\\\\\\\\\ }
  30.  
  31. Function StrNum(I:Word):D2;
  32.    var S:D2;
  33.    begin
  34.      Str(I,S);
  35.      IF I < 10 then
  36.         Insert('0',S,1);
  37.      StrNum := S;
  38.    end;
  39.  
  40. Function HexNum(L:LongInt):String;
  41. { Convert a longint type to HEX }
  42. VAR T : String[8];
  43.   BEGIN
  44.     T[0] := #8;
  45.     T[1] := HexDigits[L SHR 28];
  46.     T[2] := HexDigits[(L SHR 24) AND $F];
  47.     T[3] := HexDigits[(L SHR 20) AND $F];
  48.     T[4] := HexDigits[(L SHR 16) AND $F];
  49.     T[5] := HexDigits[(L SHR 12) AND $F];
  50.     T[6] := HexDigits[(L SHR 8) AND $F];
  51.     T[7] := HexDigits[(L SHR 4) AND $F];
  52.     T[8] := HexDigits[L AND $F];
  53.     HexNum := T;
  54. end;
  55.  
  56. Procedure ShowError(I:Word);
  57. begin
  58.   Case I of
  59.    0: Writeln('No Errors');
  60.    1:Writeln('Signature indicates there is an error.');
  61.    2:Writeln('Block read error.');
  62.    3:Writeln('Sorry file not found...');
  63.    Else Writeln('IO error.');
  64.   end;
  65.  IF I <> 3 then
  66.    Close(ZipFile);
  67.  Halt(1);
  68. end;
  69.  
  70. Procedure Anykey;
  71. VAR CH:Char;
  72. begin
  73.  HighVideo;
  74.  Writeln('Press any key to continue Esc to stop.');
  75.  NormVideo;
  76.  Ch := Readkey;
  77.  IF Ch = #27 then Halt;
  78. end;
  79.  
  80. Function Confirm(im:String):Boolean;
  81. VAr CH:Char;
  82. begin
  83.  HighVideo;
  84.  Write(im + ' Y/N?' );
  85.  NormVideo;
  86.  Repeat
  87.    Ch := UpCase(Readkey);
  88.  Until CH IN ['Y','N'];
  89.  Writeln(CH);
  90.  Confirm := (Ch = 'Y');
  91. end;
  92.  
  93. Procedure Welcome;
  94. begin
  95.   Clrscr;
  96.   Writeln('---------------------------------------------------------------');
  97.   HighVideo;
  98.   Writeln('             PKWAREU Demo for PKWareU version 1.0a ');
  99.   NormVideo;
  100.   Writeln;
  101.   Writeln(' A simple demonstration for reading PKzipped files for Turbo');
  102.   Writeln(' Pascal version 5.x.  See README.TXT for details.');
  103.   Writeln;
  104.   Writeln(' 1:  Enter the Zipped file you wish to examine.');
  105.   Writeln;
  106.   Writeln(' 2:  If the file is found, a short summary of the Zip archive will');
  107.   Writeln('     be displayed');
  108.   Writeln;
  109.   Writeln(' 3:  Each keystroke will show details of each file in the');
  110.   Writeln('     archive.');
  111.   Writeln;
  112.   Writeln('---------------------------------------------------------------');
  113.   AnyKey;
  114. end;
  115.  
  116. Procedure GetZipFile;
  117.  VAR
  118.      Error: Word;
  119. begin
  120.   Filename := '';
  121.   Write(' Enter the zipped file: ');
  122.   Readln(Filename);
  123.   If FileName = '' then ShowError(3);
  124.   Assign(ZipFile, Filename);
  125.   {$I-}
  126.    Reset(ZipFile);
  127.    Error := IOResult;
  128.   {$I+}
  129.   If Error <> 0 then
  130.     ShowError(3);
  131. end;
  132.  
  133.  
  134. Function AttrStr(Attr:LongInt):String;
  135. VAR S: String[4];
  136. begin
  137.  S := '';
  138.  IF (Attr = Archive) then
  139.     S := 'A';
  140.  IF (Attr = Hidden) then
  141.     S := S+'H';
  142.  IF (Attr = ReadOnly ) then
  143.     S := S + 'R';
  144.  IF (Attr = SysFile ) then
  145.     S := S +'S';
  146.  AttrStr := S;
  147. end;
  148.  
  149.  
  150. Function TimeStr(D:LongInt):String;
  151. VAR DT: DateTime;
  152. begin
  153.  UNpackTime(D,DT);
  154.  With DT do
  155.  begin
  156.   TimeStr :=  StrNum(Month)+'-'+StrNum(Day)+'-'+StrNum(Year-1900)+' '+
  157.               StrNum(Hour)+':'+StrNum(Min)+ ':' +StrNum(Sec);
  158.  end;
  159. end;
  160.  
  161. { ///////////////////// Function O_Sys \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ }
  162.  (*  Shows how to uses the Operating system field *)
  163. Function O_Sys(OS: Word): String;
  164. begin
  165.  Case OS OF
  166.   0 : O_Sys := 'MS-DOS or OS/2 ( F.A.T. file system )';
  167.   1 : O_Sys := 'Amiga';
  168.   2 : O_Sys := 'VAX/VMS';
  169.   3 : O_Sys := '*nix';
  170.   4 : O_Sys := 'VM/CMS';
  171.   5 : O_Sys := 'Atari ST';
  172.   6 : O_Sys := 'OS/2 H.P. File system.';
  173.   7 : O_Sys := 'Macintosh';
  174.   8 : O_Sys := 'Z-system';
  175.   9 : O_Sys := 'CP/M';
  176.   Else  O_Sys := 'un-defined operating system';
  177.  End;
  178. end;
  179.  
  180. { ////////////////////// Procedure DecodeGenPurpose \\\\\\\\\\\\\\\\\\\\\\\}
  181.             (* What the genral purpose bit is used for *)
  182.  
  183. Procedure DecodeGenPurpose;
  184.  
  185. { Notes on the General purpose bit:
  186.  
  187.   bit 0 if set file is encryped.
  188.  
  189.    if method 6  - imploded
  190.      if bit 1 is set an 8k sliding dictionary used, else 4K dictionary
  191.  
  192.      if bit 2 is set 3 Shannon-Fano trees where used to encode sliding dictionary,
  193.      else 2 Shannon-Fano trees was used to encode sliding dictionary.
  194.  
  195.    if method 8 - deflating
  196.    bit 2  bit 1
  197.      0      0     Normal conpression           (-en)
  198.      0      1     Maximum compression          (-ex)
  199.      1      0     Fast compression option used (-ef)
  200.      1      1     Super fast compression used  (-es)
  201.      undefined if other compression method was used.
  202. }
  203.  
  204. VAR GByte:Byte;
  205.  
  206. begin
  207.  GByte := LO(CFH.GenPurp);
  208.  
  209.   IF (LO(GByte) and $01) = 1 then Write('Encrupted ');
  210.  
  211.   IF CFH.Compresion = 6 then     { imploding }
  212.     begin
  213.       IF LO(GByte) and $02 <>  0 then
  214.           Write(' 8K sliding dictionary ')
  215.       Else Write(' 4K sliding dictionary ');
  216.       IF LO(GByte) and $04 <> 0 then
  217.         Write('3 Shannon-Fano trees')
  218.       Else Write('2 Shannon-Fano trees');
  219.     end;
  220.  
  221.    IF CFH.Compresion = 8 then   { deflated }
  222.     begin
  223.       IF LO(GByte) AND ($04) <> 0  then
  224.          begin
  225.            IF LO(GByte) and $02 <> 0 then
  226.               Write('Super fast compression ')
  227.            ELSE Write('Fast compression ');
  228.          end
  229.       ELSE
  230.           IF LO(GByte) and $02 <> 0 then
  231.              Write('Maximum compression ')
  232.          ELSE  Write('Normal compression ');
  233.     end;
  234.   Writeln;
  235. end;
  236.  
  237. {////////////////////// SHowFileComment \\\\\\\\\\\\\\\\\\\\\\\\\\\}
  238.     (* details correct use of Procedure GetZipComment *)
  239.  
  240. Procedure ShowFileComment;
  241. { Demo use of getZipComment routine }
  242. VAR CommentP: CommentPtr;
  243.     i,Size:Word;
  244. begin
  245.   Size := 0;
  246.   IF Confirm('This file has a comment!  View the zipfile comment') Then
  247.     GetZipComment(CommentP,Size);
  248.      If Size <> 0 then
  249.      begin
  250.    {$R-}             { turn range checking off! }
  251.      For I := 1 to Size do
  252.        Write(CommentP^[I]);
  253.     FreeMem(CommentP, Size);  { Restore the heap }
  254.     end;
  255.   {$R+}             { turn range checking on }
  256.      Writeln;
  257.     Writeln('-------------- End of comment --------------------');
  258. end;
  259.  
  260.  
  261. Procedure SHowZipStats;
  262. begin
  263.   Clrscr;
  264.   With ZipStats Do
  265.     begin
  266.       Writeln;
  267.  
  268.       Writeln('    ---- Zip Stat`s before reading central directory ---');
  269.       Write('             For file: ');
  270.       HighVideo; Writeln(FileName); NormVideo;
  271.       Writeln;
  272.       Writeln('      End Signature           : ', HexNum(EndSig));
  273.       Writeln('      Disk Number             : ', DiskNum);
  274.       Writeln('      Disk num. with start    : ', DiskwStart);
  275.       Writeln('      Number of entries       : ', NumEntries);
  276.       Writeln('      Total number of entries : ', TNumEntries);
  277.       Writeln('      Size of central dir.    : ', SizeCentral);
  278.       Writeln('      Offset of central       : ', OffsetDirRelDiskNum);
  279.       Writeln('      Size of comment         : ', CommentLen);
  280.       Writeln;
  281.    end;
  282.    Writeln('    ---------------------------------------------------');
  283.    Writeln;
  284.    IF ZipStats.CommentLen > 0 then
  285.       ShowFileComment;
  286. end;
  287.  
  288. Procedure ShowExtra(E:ExtraData);
  289. { show the Extra data fields }
  290. begin
  291.   With E do
  292.     Begin
  293.       HighVideo;
  294.       Write('          *');
  295.       LowVideo;
  296.       Write('Extra name       : ',ExtraName);
  297.       Writeln(', ',ExtraLen,' bytes.');
  298.     end;
  299. end;
  300.  
  301. Procedure ShowCFH(VAR FH: CentralFileHeadertype);
  302.  
  303.  Procedure ShowCharArray( CA: CharArray; Len: Word);
  304.  { writes out a CharArray }
  305.  VAR I : Word;
  306.  begin
  307.   For I := 1 to LEN do
  308.     Write(Ca[I]);
  309.   Writeln;
  310.  end;
  311.  
  312. begin
  313.  Clrscr;
  314.  With FH do
  315.   begin
  316.       Writeln(' File: ',PkDemo1.Filename);
  317.       Writeln('           File Number: ',EntryCount,' of ',ZipStats.TNumEntries);
  318.       Writeln('------------------------------------------------------');
  319.       Writeln('           Signature        : ' ,HexNum(CentralSig));
  320.       Writeln('           Operating system : ',O_Sys(HI(VerReq)));
  321.       Writeln('           Pkware version   : ',(LO(VerReq) DIV 10),'.',LO(VerReq) Mod 10);
  322.       Write('           General purpose  : ',GenPurp,' ');
  323.       DecodeGenPurpose;
  324.       Writeln('           Compression      : ',CompMethod[Compresion]);
  325.       Writeln('           Time             : ',lastFTime);
  326.       Writeln('           Date             : ',lastFdate);
  327.       Writeln('           CRC 32           : ',HexNum(crc32)     );
  328.       Writeln('           Compressed size  : ',Compsize  );
  329.       Writeln('           Uncompressed size: ',UnCompSize);
  330.       Writeln('           Ratio            : ',100 * (1 - CompSize/UnCompSize)  :2:0,'%');
  331.       Writeln('           Name length      : ',NameLen   );
  332.       Writeln('           Extra            : ', Extralen     );
  333.       Writeln('           Commentlen       : ', ComentLen);
  334.       Writeln('           FileName         : ',FileName );
  335.       IF ExtraLen > 0 then
  336.          ShowExtra(Extra);
  337.       If ComentLen > 0 then
  338.       begin
  339.         Write('           File Comment     : ');
  340.         ShowCharArray(FileComment, ComentLen);
  341.       end;
  342.       Writeln('           Attr             : ',AttrStr(ExternalAttr));
  343.    end;
  344.    Writeln('------------------------------------------------------');
  345. end; { SHowCFH }
  346.  
  347. begin  { Main }
  348.  Welcome;
  349.  GetZipFile;
  350.  Error := GetZipStats;
  351.  If Error = 0 then
  352.   begin
  353.     ShowZipStats;
  354.     AnyKey;
  355.     For EntryCount := 1 to ZipStats.TNumEntries do
  356.      begin
  357.        Error := ReadFileHeader(Cfh);
  358.        If Error = 0 then
  359.          begin
  360.            ShowCfh(Cfh);
  361.            AnyKey;
  362.          end
  363.        Else ShowError(Error);
  364.      end;
  365.   end { if }
  366.   Else ShowError(Error);
  367.   ShowError(0);
  368. end.
  369.